home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-4.41 / vm-digest.el < prev    next >
Encoding:
Text File  |  1989-09-11  |  5.8 KB  |  162 lines
  1. ;;; Support code for RFC934 digests
  2. ;;; Copyright (C) 1989 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (require 'vm)
  19.  
  20. (defun vm-rfc934-char-stuff-region (start end)
  21.   (setq end (vm-marker end))
  22.   (save-excursion
  23.     (goto-char start)
  24.     (while (and (< (point) end) (re-search-forward "^-" end t))
  25.       (replace-match "- -" t t)))
  26.   (set-marker end nil))
  27.  
  28. (defun vm-rfc934-char-unstuff-region (start end)
  29.   (setq end (vm-marker end))
  30.   (save-excursion
  31.     (goto-char start)
  32.     (while (and (< (point) end) (re-search-forward "^- "  end t))
  33.       (replace-match "" t t)
  34.       (forward-char)))
  35.   (set-marker end nil))
  36.  
  37. (defun vm-digestify-region (start end)
  38.   (setq end (vm-marker end))
  39.   (let ((separator-regexp (if (eq vm-folder-type 'mmdf)
  40.                   "\n+\001\001\001\001\n\001\001\001\001"
  41.                 "\n+\nFrom .*")))
  42.     (save-excursion
  43.       (vm-rfc934-char-stuff-region start end)
  44.       (goto-char start)
  45.       (insert-before-markers "------- Start of digest -------\n")
  46.       (delete-region (point) (progn (forward-line) (point)))
  47.       (while (re-search-forward separator-regexp end t)
  48.     (replace-match "\n\n------------------------------\n" t nil))
  49.       (goto-char end)
  50.       (if (eq vm-folder-type 'mmdf)
  51.       (delete-region (point) (progn (forward-line -1) (point))))
  52.       (insert-before-markers "------- End of digest -------\n")))
  53.   (set-marker end nil))
  54.  
  55. (defun vm-burst-digest ()
  56.   "Burst the current message (a digest) into its individual messages.
  57. The digest's messages are assimilated into the folder as new mail would be,
  58. e.g. message grouping takes place and if you're not reading a message
  59. you will be moved to the first new or unread message."
  60.   (interactive)
  61.   (vm-follow-summary-cursor)
  62.   (if vm-mail-buffer
  63.       (set-buffer vm-mail-buffer))
  64.   (vm-error-if-folder-empty)
  65.   (let ((inhibit-quit t) start end reg-start leader trailer
  66.     (reg-end (vm-marker nil))
  67.     (text-start (vm-marker nil))
  68.     (buffer-read-only)
  69.     (old-buffer-modified-p (buffer-modified-p))
  70.     (m (car vm-message-pointer)))
  71.     (save-excursion
  72.       (vm-save-restriction
  73.        (condition-case ()
  74.        (progn
  75.          (widen)
  76.          (goto-char (point-max))
  77.          (setq start (point))
  78.          (insert-buffer-substring (current-buffer)
  79.                       (vm-text-of (car vm-message-pointer))
  80.                       (vm-text-end-of
  81.                        (car vm-message-pointer)))
  82.          (if (not
  83.           (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t))
  84.          (error "final EB not found")
  85.            (setq end (point-marker))
  86.            ;; Reverse searchs are odd.  The above expression simply
  87.            ;; will not match  more than one message separator despite
  88.            ;; the "1 or more" directive at the end.
  89.            ;; This will have to suffice.
  90.            (while
  91.            (and
  92.             (save-excursion
  93.               (re-search-backward "\\(^-[^ ].*\n+\\|^-\n+\\)+" start t)
  94.               (= end (match-end 0))))
  95.          (set-marker end (match-beginning 0))
  96.          (goto-char end))
  97.            (skip-chars-backward "\n")
  98.            (set-marker end (point))
  99.            (delete-region end (point-max)))
  100.          (goto-char start)
  101.          (if (not (re-search-forward "^-[^ ]" end t))
  102.          (error "start EB not found")
  103.            (delete-region start (match-beginning 0)))
  104.          ;; Concoct suitable separator strings for the future messages.
  105.          (if (eq vm-folder-type 'mmdf)
  106.          (setq leader "\001\001\001\001\n"
  107.                trailer "\n\001\001\001\001\n")
  108.            (setq leader (concat "From " (vm-from-of m) " "
  109.                     (current-time-string) "\n")
  110.              trailer "\n\n"))
  111.          (goto-char start)
  112.          (while (re-search-forward
  113.              "\\(\\(\n+\\)\\|\\(^\\)\\)\\(-[^ ].*\n+\\|-\n+\\)+"
  114.              end 0)
  115.            ;; delete EB
  116.            (replace-match "" t t)
  117.            ;; stuff separator
  118.            (if (match-beginning 2)
  119.            (insert trailer))
  120.            (insert leader)
  121.            ;; Delete attribute headers so message will appear
  122.            ;; brand new to the user
  123.            (setq reg-start (point))
  124.            (save-excursion
  125.          (search-forward "\n\n" nil 0)
  126.          (set-marker text-start (point)))
  127.            (if (re-search-forward vm-attributes-header-regexp text-start t)
  128.            (delete-region (match-beginning 0) (match-end 0)))
  129.            (if vm-berkeley-mail-compatibility
  130.            (progn
  131.              (goto-char reg-start)
  132.              (if (re-search-forward vm-berkeley-mail-status-header-regexp
  133.                         text-start t)
  134.              (delete-region (match-beginning 0) (match-end 0)))))
  135.            ;; find end of message separator and unstuff the message
  136.            (goto-char reg-start)
  137.            (set-marker reg-end (if (re-search-forward "\n+-[^ ]" end 0)
  138.                        (match-beginning 0)
  139.                      (point)))
  140.            (vm-rfc934-char-unstuff-region reg-start reg-end)
  141.            (goto-char reg-end))
  142.          (goto-char end)
  143.          (insert trailer)
  144.          (set-marker end nil)
  145.          (set-marker reg-end nil)
  146.          (vm-clear-modification-flag-undos))
  147.      (error (and start (delete-region start (point-max)))
  148.         (set-buffer-modified-p old-buffer-modified-p)
  149.         (error "Malformed digest")))))
  150.     (if (vm-assimilate-new-messages)
  151.     (progn
  152.       (vm-emit-totals-blurb)
  153.       ;; If there's a current grouping, then the summary has already
  154.       ;; been redone in vm-group-messages.
  155.       (if (and vm-summary-buffer (not vm-current-grouping))
  156.           (progn
  157.         (vm-do-summary)
  158.         (vm-emit-totals-blurb)))
  159.       (vm-thoughtfully-select-message)
  160.       (if vm-summary-buffer
  161.           (vm-set-summary-pointer (car vm-message-pointer)))))))
  162.